home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / copascal.arc / COPASCAL.PAS < prev    next >
Pascal/Delphi Source File  |  1986-06-18  |  15KB  |  537 lines
  1. (*
  2.  
  3.                   The  * Co-Pascal *  COMPILER
  4.  
  5.    ...is a modified version of the PASCAL-S compiler to permit
  6.    interleaved concurrent program execution.  The reserved words
  7.    "COBEGIN" and "COEND" mark concurrent blocks while calls to
  8.    the predefined functions WAIT and SIGNAL provide synchronization.
  9.    The changes are from "Principles of Concurrent Programming by
  10.    BEN-ARI.
  11.  
  12.    The defining document for PASCAL-S is:
  13.  
  14.      PASCAL-S: A SUBSET AND ITS IMPLEMENTATION by N. WIRTH.
  15.  
  16.  
  17.    HISTORY:
  18.  
  19.    .  PASCAL-S developed by N. Wirth,  1976.
  20.  
  21.    .  PASCAL-S modified for the HP/3000 by D. Greer.
  22.  
  23.    .  M. Ben-Ari develops additions to the Pascal language to provide
  24.       for simulated concurrency.  See Ben-Ari : 'Principles of Concurrent
  25.       Programming.  Pretice-Hall, 1982.
  26.  
  27.    .  B. Burd incorporates Ben-Ari's changes into PASCAL-S,
  28.       developing CO-PASCAL for the VAX/11-750 under VMS, 1985.
  29.  
  30.    .  C. Schoening modifies and enhances CO-PASCAL for Turbo-Pascal v2.0
  31.       under CP/M and MS-DOS, 1985.
  32.  
  33.  
  34. *)
  35.  
  36.  
  37. program Co_Pascal( INPUT, OUTPUT );
  38.  
  39. {$R+}
  40. {$I HEADER.MOD }
  41.  
  42. (*------------------------------------------------------COMPILE-----*)
  43.  
  44. overlay procedure compile;
  45.  
  46. const KEY : array[1..NKW] of string[10] =
  47.           ( 'AND       ', 'ARRAY     ',
  48.             'BEGIN     ', 'CASE      ',
  49.             'COBEGIN   ', 'COEND     ',
  50.             'CONST     ', 'DIV       ',
  51.             'DO        ', 'DOWNTO    ',
  52.             'ELSE      ', 'END       ',
  53.             'FOR       ', 'FUNCTION  ',
  54.             'IF        ', 'MOD       ',
  55.             'NOT       ', 'OF        ',
  56.             'OR        ', 'PROCEDURE ',
  57.             'PROGRAM   ', 'RECORD    ',
  58.             'REPEAT    ', 'THEN      ',
  59.             'TO        ', 'TYPE      ',
  60.             'UNTIL     ', 'VAR       ',
  61.             'WHILE     ' );
  62.  
  63.  
  64. type  SYMBOL = ( INTCON, REALCON, CHARCON, WORD,
  65.                  PLUS, MINUS, TIMES, IDIV, RDIV, IMOD,
  66.                  NOTSY, ANDSY, ORSY,
  67.                  EQL, NEQ, GTR, GEQ, LSS, LEQ,
  68.                  LPARENT, RPARENT, LBRACK, RBRACK,
  69.                  COMMA, SEMICOLON, PERIOD, COLON,
  70.                  BECOMES, CONSTSY, TYPESY, VARSY, ARRAYSY, RECORDSY,
  71.                  FUNCSY, PROCSY, PROGRAMSY, IDENT, BEGINSY, ENDSY,
  72.                  REPEATSY, UNTILSY, WHILESY, DOSY, FORSY,
  73.                  IFSY, THENSY, ELSESY, CASESY, OFSY, TOSY, DOWNTOSY );
  74.  
  75.       SYMSET = SET OF SYMBOL;
  76.  
  77. const KSY : array[1..NKW] of SYMBOL =
  78.             ( ANDSY,        ARRAYSY,       BEGINSY,       CASESY,
  79.               BEGINSY,      ENDSY,         CONSTSY,       IDIV,
  80.               DOSY,         DOWNTOSY,      ELSESY,        ENDSY,
  81.               FORSY,        FUNCSY,        IFSY,          IMOD,
  82.               NOTSY,        OFSY,          ORSY,          PROCSY,
  83.               PROGRAMSY,    RECORDSY,      REPEATSY,      THENSY,
  84.               TOSY,         TYPESY,        UNTILSY,       VARSY,
  85.               WHILESY );
  86.  
  87. var   DISPLAY : ARRAY [ 0 .. LMAX ] of INTEGER;
  88.       SPS     : ARRAY [ ' '.. ']' ] of SYMBOL;
  89.  
  90. (*
  91.    =============================
  92.    key words and special symbols
  93.    =============================
  94. *)
  95.  
  96.    (* indicies to tables  *)
  97.  
  98.     T,   (* ---> TAB,    *)
  99.     A,   (* ---> ATAB,   *)
  100.     SX,  (* ---> STAB,   *)
  101.     C1,  (* ---> RCONST, *)
  102.     C2,  (* ---> RCONST  *)
  103.  
  104.     LC   (* program Location Counter *) : INTEGER;
  105.  
  106. (*
  107.       =========================
  108.        Error Control Variables
  109.       =========================
  110. *)
  111.  
  112.     ERRS     : SET OF 0..ERMAX;  (* compilation errors        *)
  113.     ERRPOS   : INTEGER;
  114.     SKIPFLAG : BOOLEAN;          (* used by procedure ENDSKIP *)
  115.  
  116. (*
  117.       =============================
  118.       Insymbol (scanner) Variables
  119.       =============================
  120. *)
  121.  
  122.     SY    : SYMBOL;     (* last symbol read by INSYMBOL *)
  123.     ID    : ALFA;       (* identifier from     INSYMBOL *)
  124.     INUM  : INTEGER;    (* integer from        INSYMBOL *)
  125.     RNUM  : REAL;       (* real number from    INSYMBOL *)
  126.     SLENG : INTEGER;    (* string length                *)
  127.     CHARTP: ARRAY[CHAR] OF CHTP;     (* character types *)
  128.     LINE  : ARRAY [1..LLNG] OF CHAR; (* input line      *)
  129.     CC    : INTEGER;    (* character counter            *)
  130.     LL    : INTEGER;    (* length of current line       *)
  131.     LINECOUNT: INTEGER; (* source line counter          *)
  132.  
  133.  
  134. (*
  135.    ======
  136.     sets
  137.    ======
  138. *)
  139.  
  140.     CONSTBEGSYS, TYPEBEGSYS,
  141.     BLOCKBEGSYS, FACBEGSYS, STATBEGSYS : SYMSET;
  142.  
  143.  
  144.  
  145. (*--------------------------------------------------------ERROR-----*)
  146.  
  147. procedure ERROR( N : INTEGER );
  148. (*
  149.    write error on current line & add to TOT ERR
  150. *)
  151. begin
  152.   if ERRPOS = 0 then write('[**> ', ' ':6);
  153.   if CC > ERRPOS then begin
  154.      write( ' ': CC-ERRPOS, '^', N:2 );
  155.      ERRPOS := CC+3;
  156.      ERRS := ERRS + [N];
  157.   end;
  158. end; { ERROR }
  159.  
  160. (*-----------------------------------------------------ENDSKIP------
  161.  
  162.    ENDSKIP changed to just print blanks for skipped symbols.
  163.    This should cause less confusion than the underlining did.
  164. *)
  165.  
  166. procedure ENDSKIP;    (* underline skipped part of input *)
  167. begin
  168.   while ERRPOS < CC do begin
  169.     write(' ');
  170.     ERRPOS := ERRPOS + 1;
  171.   end;
  172.   SKIPFLAG := FALSE;
  173. end; { ENDSKIP }
  174.  
  175. procedure FATAL( N : integer ); forward;
  176. procedure NEXTCH; forward;
  177.  
  178. (*---------------------------------------------------------EMIT-----
  179.    emit actual code into the code table
  180. *)
  181. procedure EMIT(FCT: INTEGER);
  182. begin
  183.    if LC = CMAX then FATAL(6);
  184.    CODE[LC].F := FCT;
  185.    LC := LC+1;
  186. end; { EMIT }
  187.  
  188. procedure EMIT1(FCT,B: INTEGER);
  189. begin
  190.   if LC = CMAX then FATAL(6);
  191.   with CODE[LC] do begin
  192.     F := FCT;
  193.     Y := B;
  194.   end;
  195.   LC := LC+1;
  196. end; { EMIT1 }
  197.  
  198. procedure EMIT2(FCT,A,B: INTEGER);
  199. begin
  200.   if LC = CMAX then FATAL(6);
  201.   with CODE[LC] do begin
  202.     F := FCT;
  203.     X := A;
  204.     Y := B;
  205.   end;
  206.   LC := LC+1;
  207. end; { EMIT2 }
  208.  
  209. (*-----------------------INITTABLES----ERRORMSG----ENTERSTDFCNS-----*)
  210.  
  211. {$I INIT.MOD }
  212.  
  213. (*-----------------------------------------------------INSYMBOL-----*)
  214.  
  215. {$I INSYMBOL.MOD }
  216.  
  217. (*--------------------------------------------------PRINTTABLES-----
  218.    this procedure prints out the internal compiler and
  219.    interpreter tables.  This procedure is called if the
  220.    DEBUG flag is TRUE.
  221. *)
  222.  
  223. procedure PRINTTABLES;
  224. var I: INTEGER;
  225.     O: ORDER;
  226. begin
  227.    writeln;
  228.    writeln(' Identifiers          Link  Obj  Typ  Ref  NRM  Lev  Adr');
  229.    for I := BTAB[1].LAST +1 to T do with TAB[I] do
  230.      writeln(I,' ',NAME,LINK:5, ORD(OBJ):5, ORD(TYP):5, REF:5,
  231.              ORD(NORMAL):5, LEV:5, ADR:5);
  232.    writeln(' Blocks    Last LPar PSze Vsze');
  233.    for I := 1 to B do with BTAB[I] do
  234.      writeln(I, LAST:5, LASTPAR:5, PSIZE:5, VSIZE:5);
  235.    writeln;
  236.    writeln(' Arrays    Xtyp Etyp Eref  Low High Elsz Size');
  237.    for I := 1 to A do with ATAB[I] do
  238.      writeln(I, ORD(INXTYP):5, ORD(ELTYP):5,
  239.        ELREF:5, LOW:5, HIGH:5, ELSIZE:5, SIZE:5);
  240.    writeln(' CODE:');
  241.    for I := 0 to LC-1 do begin
  242.      if I MOD 5 = 0 then begin
  243.        writeln; write(I:5)
  244.      end;
  245.      O := CODE[I];
  246.      write(O.F:5);
  247.      if O.F < 31 then
  248.        if O.F < 4 then write(O.X:2, O.Y:5)
  249.                   else write(O.Y:7)
  250.      else write('       ');
  251.      write(',');
  252.    end;
  253.    writeln;
  254. end; { PRINTTABLES }
  255.  
  256. (*--------------------------------------------------------BLOCK-----*)
  257.  
  258. {$I BLOCKA.MOD }
  259. {$I BLOCKB.MOD }
  260. {$I BLOCKC.MOD }
  261.  
  262. (*--------------------------------------------------------FATAL-----*)
  263.  
  264. procedure FATAL;  (* internal table overflow *)
  265. begin
  266.   if ERRS <> [] then ERRORMSG;
  267.   writeln;
  268.   write( 'COMPILER TABLE for ' );
  269.   case N of
  270.     1 : write( 'IDENTIFIER' );
  271.     2 : write( 'PROCEDURES' );
  272.     3 : write(      'REALS' );
  273.     4 : write(     'ARRAYS' );
  274.     5 : write(     'LEVELS' );
  275.     6 : write(       'CODE' );
  276.     7 : write(    'STRINGS' );
  277.   end;
  278.   writeln( ' is too SMALL' );
  279.   writeln;
  280.   writeln(' Please take this output to the maintainer of ');
  281.   writeln(' this language for your installation '         );
  282.   writeln; writeln;
  283.   writeln(' FATAL termination of Co-Pascal');
  284.   HALT;
  285. end; { FATAL }
  286.  
  287. (*-------------------------------------------------------NEXTCH-----*)
  288.  
  289. procedure NEXTCH;   (* read next char; process line end *)
  290. begin
  291.   if CC = LL then begin
  292.     if EOF( SOURCE ) then begin
  293.       writeln;
  294.       writeln(' PROGRAM INCOMPLETE');
  295.       ERRORMSG;
  296.       HALT;
  297.     end;
  298.     if ERRPOS <> 0 then begin
  299.       if SKIPFLAG then endSKIP;
  300.       ERRPOS := 0;
  301.       writeln;
  302.     end;
  303.     LINECOUNT := LINECOUNT + 1;
  304.     write( LINECOUNT:4,'  ' );
  305.     write( LC:5, '  ' );
  306.     LL := 0;
  307.     CC := 0;
  308.     while NOT EOLN(SOURCE) do begin
  309.       LL := LL+1;
  310.       read( SOURCE,CH);
  311.       write(CH);
  312.       LINE[LL] := CH
  313.     end;
  314.     LL := LL + 1;
  315.     writeln;
  316.     readln( SOURCE );
  317.     LINE[LL] := ' ';
  318.   end;
  319.   CC := CC+1;
  320.   CH := LINE[CC];
  321.   if (ORD(CH) < ORD(' ')) then ERROR(60)
  322. end; { NEXTCH }
  323.  
  324.  
  325. begin { COMPILE }
  326.  
  327. (*
  328.    =============================
  329.      check for program heading
  330.    =============================
  331. *)
  332.  
  333.   INITIALIZE;
  334.   INSYMBOL;
  335.   if SY <> PROGRAMSY then ERROR(3) else begin
  336.     INSYMBOL;
  337.     if SY <> IDENT then ERROR(2) else begin
  338.       PROGNAME := ID;
  339.       INSYMBOL;
  340.       if SY <> LPARENT then ERROR(9) else repeat
  341.         INSYMBOL;
  342.         if SY <> IDENT then ERROR(2) else begin
  343.           if ID = 'INPUT     ' then IFLAG := TRUE
  344.             else if ID = 'OUTPUT    ' then OFLAG := TRUE
  345.               else if ( NOT DFLAG ) then begin
  346.                 DFILE := '          ';
  347.                 M := 0;
  348.                 while ID[m+1] in [ 'A'..'Z', '0'..'9', ':' ]
  349.                   do M := M + 1;
  350.                 MOVE( ID, DFILE[11-m], m );
  351.                 DFLAG := TRUE;
  352.                 writeln( ' DFLAG <- TRUE ', DFILE, m:5 );
  353.               end else ERROR(0);
  354.           INSYMBOL;
  355.         end;
  356.       until SY <> COMMA;
  357.       if SY = RPARENT then INSYMBOL else ERROR(4);
  358.       if NOT OFLAG then ERROR(20)
  359.     end
  360.   end;
  361.  
  362.   ENTERSTDFCNS;
  363.  
  364.   with BTAB[1] do begin
  365.    LAST := T;
  366.    LASTPAR := 1;
  367.    PSIZE := 0;
  368.    VSIZE := 0
  369.   end;
  370.  
  371. (*
  372.    ============
  373.      COMPILE
  374.    ============
  375. *)
  376.  
  377.   block( BLOCKBEGSYS+STATBEGSYS, FALSE, 1 );
  378.  
  379.   if (SY <> PERIOD) then ERROR(22);
  380.   EMIT(31);  (* halt *)
  381.   if ( BTAB[2].VSIZE > STMAX-STKINCR * PMAX ) then ERROR(49);
  382.   if DEBUG then PRINTTABLES;
  383.   if ERRS <> [] then begin
  384.     ERRORMSG;
  385.     HALT;
  386.   end;
  387. end; { COMPILE }
  388.  
  389. (*----------------------------------------------------INTERPRET------*)
  390.  
  391. overlay procedure INTERPRET;
  392.  
  393. {$I INTERPT.MOD  }
  394.  
  395. end; { INTERPRET }
  396.  
  397. (*---------------------------------------------------P_CODE I/O-----*)
  398.  
  399. procedure PutBlock( FileName : FNAME );
  400. var ObjFile : file;
  401.     t       : string[ 3];
  402.     len     : integer;
  403.  
  404. begin
  405.   assign( ObjFile, FileName + '.OBJ' );
  406.   rewrite( ObjFile );
  407.   for len := 1 to 25 do SS[len] := ' ';
  408.   len := length( SFILE );
  409.   MOVE( SFILE[1], SS[11-len], len );
  410.   if DFLAG then MOVE( DFILE[1], SS[11], 10 );
  411.   MOVE( IFLAG, SS[21], 1 );
  412.   MOVE( OFLAG, SS[22], 1 );
  413.   MOVE( DFLAG, SS[23], 1 );
  414.   MOVE( B    , SS[24], 2 );
  415.  
  416.   blockwrite( ObjFile,    TAB, ( SizeOf(   TAB) DIV 128 )+1 );
  417.   blockwrite( ObjFile,   ATAB, ( SizeOf(  ATAB) DIV 128 )+1 );
  418.   blockwrite( ObjFile,   BTAB, ( SizeOf(  BTAB) DIV 128 )+1 );
  419.   blockwrite( ObjFile,   STAB, ( SizeOf(  STAB) DIV 128 )+1 );
  420.   blockwrite( ObjFile,   CODE, ( SizeOf(  CODE) DIV 128 )+1 );
  421.   blockwrite( ObjFile, RCONST, ( SizeOf(RCONST) DIV 128 )+1 );
  422.   blockwrite( ObjFile,     SS, ( SizeOf(    SS) DIV 128 )+1 );
  423.   close( ObjFile );
  424. end;
  425.  
  426. procedure GetBlock( FileName : FNAME );
  427.  
  428. type temptr  = ^tempdat;
  429.      tempdat = array [1..128] of 0..255;
  430.  
  431. var ObjFile : file;
  432.     a       : temptr;
  433.     temp    : tempdat;
  434.     len     : integer;
  435.  
  436.   procedure B_read( var varname; q : integer );
  437.   begin
  438.     blockread( ObjFile, varname, ( Q DIV 128 ) );
  439.     blockread( ObjFile, temp, 1 );
  440.     a := ptr( Seg(varname), Ofs(varname) + 128*( Q DIV 128 ) );
  441.     move( temp, a^, ( Q MOD 128 ) );
  442.   end;
  443.  
  444. begin
  445.   assign( ObjFile, FileName + '.OBJ' );
  446.   reset( ObjFile );
  447.   B_read(    TAB, SizeOf(    TAB ));
  448.   B_read(   ATAB, SizeOf(   ATAB ));
  449.   B_read(   BTAB, SizeOf(   BTAB ));
  450.   B_read(   STAB, SizeOf(   STAB ));
  451.   B_read(   CODE, SizeOf(   CODE ));
  452.   B_read( RCONST, SizeOf( RCONST ));
  453.   B_read(     SS, SizeOf(     SS ));
  454.   len := 1;
  455.   while SFILE[len] = ' ' do len := len+1;
  456.   MOVE( SS[len], SFILE[1],10 );  SFILE[0] := CHR( 11-len );
  457.   MOVE( SS[ 21],    IFLAG, 1 );
  458.   MOVE( SS[ 22],    OFLAG, 1 );
  459.   MOVE( SS[ 23],    DFLAG, 1 );
  460.   MOVE( SS[ 24],        B, 2 );
  461.   if DFLAG then MOVE( SS[11], DFILE[1], 10 );  DFILE[0] := CHR(10);
  462.   if DEBUG then begin
  463.     writeln;
  464.     write('  S: ',SFILE+'.PAS     ');
  465.     if DFLAG then writeln('D: ',DFILE+'.DAT' ) else writeln;
  466.     writeln(' flags I/O/D :',IFLAG:8,OFLAG:6,DFLAG:6,'     B : ',B );
  467.     writeln;
  468.   end;
  469. end;
  470.  
  471. procedure HELP;
  472. begin
  473.   writeln;
  474.   writeln(' Selection error.  Correct syntax is :  FNAME -X* ');
  475.   writeln;
  476.   writeln(' where FNAME is a legal file name with the .TYP optional ');
  477.   writeln(' and the <X> option is one of the following : ');
  478.   writeln;
  479.   writeln('    C :: compile the source code to P-code ');
  480.   writeln('    E :: execute a previously compiled P-code ');
  481.   writeln('    R :: compile and then execute  ');
  482.   writeln;
  483.   writeln('    * is an optional flag to display debug information ');
  484.   writeln;
  485.   halt;
  486. end;
  487.  
  488. begin { MAIN }
  489.  
  490.   if ( ParamCount < 1 ) then HELP;
  491.   SFILE := ParamStr(1);
  492.   for m := 1 to length( SFILE ) do SFILE[m] := UpCase( SFILE[m] );
  493.   assign( SOURCE, SFILE+'.PAS' );
  494.   {$I-}
  495.   reset( SOURCE )
  496.   {$I+};
  497.   if IOresult <> 0 then begin
  498.     writeln('Cannot find file : ', SFILE+'.PAS' );
  499.     halt;
  500.   end;
  501.   writeln; writeln(' ':10,HEADER); writeln;
  502.  
  503.   if ( ParamCount < 2 ) then begin
  504.     OPTION := 'R';
  505.     DEBUG  := FALSE;
  506.   end else begin
  507.     CmdLine := ParamStr(2);
  508.     if ( CmdLine[1] = '-' ) then OPTION := UpCase( CmdLine[2] ) else HELP;
  509.     if ( CmdLine[3] = '*' ) then DEBUG := TRUE else DEBUG := FALSE;
  510.   end;
  511.  
  512.   case OPTION of
  513.  
  514.     'C' : begin
  515.             COMPILE;
  516.             PutBlock( SFILE );
  517.           end;
  518.  
  519.     'E' : begin
  520.             GetBlock( SFILE );
  521.             INTERPRET;
  522.           end;
  523.  
  524.     'R' : begin
  525.             COMPILE;
  526.             writeln;
  527.             writeln(' begin execution for : ', PROGNAME );
  528.             writeln;
  529.             INTERPRET;
  530.           end;
  531.  
  532.     else HELP;
  533.   end;
  534.  
  535.   writeln;
  536. end.
  537.